home *** CD-ROM | disk | FTP | other *** search
/ Inter.Net 55-2 / Inter.Net 55-2.iso / Mandrake / mdkinst / usr / lib / perl5 / 5.00503 / overload.pm < prev    next >
Encoding:
Perl POD Document  |  2000-01-12  |  3.3 KB  |  146 lines
  1. package overload;
  2.  
  3. sub nil {}
  4.  
  5. sub OVERLOAD {
  6.   $package = shift;
  7.   my %arg = @_;
  8.   my ($sub, $fb);
  9.   $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
  10.   *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
  11.   for (keys %arg) {
  12.     if ($_ eq 'fallback') {
  13.       $fb = $arg{$_};
  14.     } else {
  15.       $sub = $arg{$_};
  16.       if (not ref $sub and $sub !~ /::/) {
  17.     $ {$package . "::(" . $_} = $sub;
  18.     $sub = \&nil;
  19.       }
  20.       #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
  21.       *{$package . "::(" . $_} = \&{ $sub };
  22.     }
  23.   }
  24.   ${$package . "::()"} = $fb; # Make it findable too (fallback only).
  25. }
  26.  
  27. sub import {
  28.   $package = (caller())[0];
  29.   # *{$package . "::OVERLOAD"} = \&OVERLOAD;
  30.   shift;
  31.   $package->overload::OVERLOAD(@_);
  32. }
  33.  
  34. sub unimport {
  35.   $package = (caller())[0];
  36.   ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
  37.   shift;
  38.   for (@_) {
  39.     if ($_ eq 'fallback') {
  40.       undef $ {$package . "::()"};
  41.     } else {
  42.       delete $ {$package . "::"}{"(" . $_};
  43.     }
  44.   }
  45. }
  46.  
  47. sub Overloaded {
  48.   my $package = shift;
  49.   $package = ref $package if ref $package;
  50.   $package->can('()');
  51. }
  52.  
  53. sub ov_method {
  54.   my $globref = shift;
  55.   return undef unless $globref;
  56.   my $sub = \&{*$globref};
  57.   return $sub if $sub ne \&nil;
  58.   return shift->can($ {*$globref});
  59. }
  60.  
  61. sub OverloadedStringify {
  62.   my $package = shift;
  63.   $package = ref $package if ref $package;
  64.   #$package->can('(""')
  65.   ov_method mycan($package, '(""'), $package
  66.     or ov_method mycan($package, '(0+'), $package
  67.     or ov_method mycan($package, '(bool'), $package
  68.     or ov_method mycan($package, '(nomethod'), $package;
  69. }
  70.  
  71. sub Method {
  72.   my $package = shift;
  73.   $package = ref $package if ref $package;
  74.   #my $meth = $package->can('(' . shift);
  75.   ov_method mycan($package, '(' . shift), $package;
  76.   #return $meth if $meth ne \&nil;
  77.   #return $ {*{$meth}};
  78. }
  79.  
  80. sub AddrRef {
  81.   my $package = ref $_[0];
  82.   return "$_[0]" unless $package;
  83.   bless $_[0], overload::Fake;    # Non-overloaded package
  84.   my $str = "$_[0]";
  85.   bless $_[0], $package;    # Back
  86.   $package . substr $str, index $str, '=';
  87. }
  88.  
  89. sub StrVal {
  90.   (OverloadedStringify($_[0])) ?
  91.     (AddrRef(shift)) :
  92.     "$_[0]";
  93. }
  94.  
  95. sub mycan {                # Real can would leave stubs.
  96.   my ($package, $meth) = @_;
  97.   return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
  98.   my $p;
  99.   foreach $p (@{$package . "::ISA"}) {
  100.     my $out = mycan($p, $meth);
  101.     return $out if $out;
  102.   }
  103.   return undef;
  104. }
  105.  
  106. %constants = (
  107.           'integer'      =>  0x1000, 
  108.           'float'      =>  0x2000,
  109.           'binary'      =>  0x4000,
  110.           'q'      =>  0x8000,
  111.           'qr'      => 0x10000,
  112.          );
  113.  
  114. %ops = ( with_assign      => "+ - * / % ** << >> x .",
  115.      assign          => "+= -= *= /= %= **= <<= >>= x= .=",
  116.      str_comparison      => "< <= >  >= == !=",
  117.      '3way_comparison'=> "<=> cmp",
  118.      num_comparison      => "lt le gt ge eq ne",
  119.      binary          => "& | ^",
  120.      unary          => "neg ! ~",
  121.      mutators      => '++ --',
  122.      func          => "atan2 cos sin exp abs log sqrt",
  123.      conversion      => 'bool "" 0+',
  124.      special      => 'nomethod fallback =');
  125.  
  126. sub constant {
  127.   # Arguments: what, sub
  128.   while (@_) {
  129.     $^H{$_[0]} = $_[1];
  130.     $^H |= $constants{$_[0]} | 0x20000;
  131.     shift, shift;
  132.   }
  133. }
  134.  
  135. sub remove_constant {
  136.   # Arguments: what, sub
  137.   while (@_) {
  138.     delete $^H{$_[0]};
  139.     $^H &= ~ $constants{$_[0]};
  140.     shift, shift;
  141.   }
  142. }
  143.  
  144. 1;
  145.  
  146.